home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / H245.ZIP / NFSRC21.ZIP / TBWHILE.PRG < prev    next >
Text File  |  1991-09-28  |  16KB  |  501 lines
  1. /*
  2.  * File......: TBWHILE.PRG
  3.  * Author....: Jim Orlowski
  4.  * Date......: $Date:   28 Sep 1991 02:56:56  $
  5.  * Revision..: $Revision:   1.4  $
  6.  * Log file..: $Logfile:   E:/nanfor/src/tbwhile.prv  $
  7.  * 
  8.  * This is an original work by Jim Orlowski and is placed in the
  9.  * public domain.
  10.  *
  11.  * Modification history:
  12.  * ---------------------
  13.  *
  14.  * $Log:   E:/nanfor/src/tbwhile.prv  $
  15.  * 
  16.  *    Rev 1.4   28 Sep 1991 02:56:56   GLENN
  17.  * Moved Jim's "Tricks used" comment out of the file header and
  18.  * into the source code area.
  19.  * 
  20.  *    Rev 1.3   28 Sep 1991 02:52:22   GLENN
  21.  * Jim's modifications:
  22.  * 
  23.  *  1.  Changed SAVESCREEN() and RESTSCREEN to use MaxRow(), MaxCol()
  24.  *      instead of 24,79
  25.  * 
  26.  *  2.  Added Nantucket's cleaner code for:
  27.  *        - Cleaned up logic around line 334 while loop section
  28.  *        - Added refreshCurrent and another stabilize around line 349
  29.  *        - TbSkipWhile was redone 
  30.  *             Note: Leo's line was changed to:
  31.  *                 ELSEIF ( n > 0 .AND. RECNO() <> LASTREC() + 1)
  32.  * 
  33.  *  3.  Added DispBegin() and DispEnd() around both Stabilize sections
  34.  * 
  35.  * 
  36.  * 
  37.  * 
  38.  *    Rev 1.2   15 Aug 1991 23:04:20   GLENN
  39.  * Forest Belt proofread/edited/cleaned up doc
  40.  * 
  41.  *    Rev 1.1   14 Jun 1991 19:53:08   GLENN
  42.  * Minor edit to file header
  43.  * 
  44.  *    Rev 1.0   01 Apr 1991 01:02:22   GLENN
  45.  * Nanforum Toolkit
  46.  *
  47.  */
  48.  
  49.  
  50.  
  51. /* The tricks are: 
  52.  *
  53.  * 1. Setting up functions for goTop() and goBottom() so that you can 
  54.  *    quickly move to the right record when the user presses the 
  55.  *    Ctrl-PgUp ( goTop() ) and Ctrl-PgDn ( goBottom() ) keys.
  56.  *
  57.  * 2. Passing and evaluating the block for the TbSkipWhil().
  58.  */
  59.  
  60.  
  61. #command DEFAULT <param> TO <val> [, <paramn> TO <valn> ];
  62. => ;
  63.          <param> := IIF(<param> = NIL, <val>, <param> ) ;
  64.          [; <paramn> := IIF(<paramn> = NIL, <valn>, <paramn> ) ]
  65. #include "inkey.ch"
  66.  
  67.  
  68. #ifdef FT_TEST
  69.  
  70.   /*
  71.    *   THIS DEMO SHOWS TBNAMES.DBF CONSISTING OF LAST, FIRST, ADDR, CITY,
  72.    *   STATE, ZIP WITH ACTIVE INDEX ON LAST + FIRST.  IT SHOWS LAST NAME,
  73.    *   FIRST NAME, CITY ONLY FOR THOSE LAST NAMES THAT BEGIN WITH LETTER
  74.    *   THAT YOU INPUT FOR THE CKEY GET.
  75.    *
  76.    *   TBNAMES.DBF/.NTX ARE AUTOMATICALLY CREATED BY THIS TEST PROGRAM
  77.    */
  78.  
  79.   #INCLUDE "SETCURS.CH"
  80.  
  81.   FUNCTION TBWHILE()
  82.      LOCAL aFields := {}, cKey := "O", cOldColor
  83.      LOCAL nFreeze := 1, lSaveScrn := .t., nRecSel
  84.      LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
  85.      LOCAL cColorShad := "N/N"
  86.      FIELD last, first
  87.      MEMVAR GetList
  88.  
  89.      IF ! FILE( "TBNAMES.DBF" )
  90.         MAKE_DBF()
  91.      ENDIF
  92.  
  93.      USE TBNames
  94.  
  95.      IF ! FILE( "TBNAMES.NTX" )
  96.         INDEX ON last + first TO TBNAMES
  97.      ENDIF
  98.  
  99.      SET INDEX TO TBNAMES
  100.  
  101.      * Pass Heading as character and Field as Block including Alias
  102.      * To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
  103.  
  104.      AADD(aFields, {"Last Name" , {||TBNames->Last}  } )
  105.      AADD(aFields, {"First Name", {||TBNames->First} } )
  106.      AADD(aFields, {"City"      , {||TBNames->City}  } )
  107.  
  108.      cOldColor := SetColor("N/BG")
  109.      CLEAR SCREEN
  110.      @ 5,10 SAY "Enter First Letter Of Last Name:" GET cKey PICTURE "!"
  111.      READ
  112.  
  113.      * TBNames->Last = cKey is the Conditional Block passed to this function
  114.      * you can make it as complicated as you want, but you would then
  115.      * have to modify TBWhileSet() to find first and last records
  116.      * matching your key.
  117.      nRecSel := FT_BRWSWHL( aFields, {||TBNames->Last = cKey}, cKey, nFreeze,;
  118.         lSaveScrn, cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6)
  119.      * Note you can use Compound Condition 
  120.      * such as cLast =: "Pierce            " and cFirst =: "Hawkeye  "
  121.      * by changing above block to:
  122.      *    {||TBNames->Last = cLast .AND. TBNames->First = cFirst}
  123.      * and setting cKey := cLast + cFirst
  124.  
  125.      ?
  126.      IF nRecSel == 0
  127.         ? "Sorry, NO Records Were Selected"
  128.      ELSE
  129.         ? "You Selected " + TBNames->Last +" "+ ;
  130.            TBNames->First +" "+ TBNames->City
  131.      ENDIF
  132.      ?
  133.  
  134.      WAIT
  135.      SetColor(cOldColor)
  136.      CLEAR SCREEN
  137.   RETURN nil
  138.  
  139.   STATIC FUNCTION make_dbf
  140.   LOCAL x, aData := {                                                               ;
  141.      { "SHAEFER","KATHRYN","415 WEST CITRUS ROAD #150","LOS ANGELES","CA","90030" },;
  142.      { "OLSON","JAMES","225 NORTH RANCH ROAD","LOS ANGELES","CA","90023"          },;
  143.      { "KAYBEE","JOHN","123 SANDS ROAD","CAMARILLO","CA","93010"                  },;
  144.      { "HERMAN","JIM","123 TOON PAGE ROAD","VENTURA","CA","93001"                 },;
  145.      { "BURNS","FRANK","123 VIRGINA STREET","OXNARD","CA","93030"                 },;
  146.      { "PIERCE","HAWKEYE","123 OLD TOWN ROAD","PORT MUGU","CA","93043"            },;
  147.      { "MORGAN","JESSICA","123 FRONTAGE ROAD","CAMARILLO","CA","93010"            },;
  148.      { "POTTER","ROBERT","123 FIR STREET","OXNARD","CA","93030"                   },;
  149.      { "WORTH","MARY","123-1/2 JOHNSON DRIVE","OXNARD","CA","93033"               },;
  150.      { "JOHNSON","SUSAN","123 QUEENS STREET","OXNARD","CA","93030"                },;
  151.      { "SAMSON","SAM","215 MAIN STREET","OXNARD","CA","93030"                     },;
  152.      { "NEWNAME","JAMES","215 MAIN STREET","LOS ANGELES","CA","90000"             },;
  153.      { "OLEANDAR","JILL","425 FLORAL PARK DRIVE","FLORAL PARK","NY","10093"       },;
  154.      { "SUGARMAN","CANDY","1541 SWEETHEART ROAD","HERSHEY","PA","10132"           } }
  155.  
  156.   DbCreate( "TBNAMES", { { "LAST ", "C", 18, 0, } ,;
  157.                          { "FIRST", "C",  9, 0, } ,;
  158.                          { "ADDR ", "C", 28, 0, } ,;
  159.                          { "CITY ", "C", 21, 0, } ,;
  160.                          { "STATE", "C",  2, 0, } ,;
  161.                          { "ZIP  ", "C",  9, 0, } } )
  162.   USE tbnames
  163.   FOR x := 1 TO Len( aData )
  164.      APPEND BLANK
  165.      Aeval( aData[x], {|e,n| FieldPut( n, e ) } )
  166.   NEXT
  167.   USE
  168.   RETURN NIL
  169.  
  170. #endif
  171.  
  172. /* ------------------------------------------------------------------- */
  173.  
  174. /*  $DOC$
  175.  *  $FUNCNAME$
  176.  *     FT_BRWSWHL()
  177.  *  $CATEGORY$
  178.  *     Menus/Prompts
  179.  *  $ONELINER$
  180.  *     Browse an indexed database limited to a while condition
  181.  *  $SYNTAX$
  182.  *     FT_BRWSWHL( <aFields>, <bWhileCond>, <cKey>,                  ;
  183.  *                 [ <nFreeze> ], [ <lSaveScrn> ], [ <cColorList> ], ;
  184.  *                 [ <cColorShadow> ], [ <nTop> ], [ <nLeft> ],      ;
  185.  *                 [ <nBottom> ], [ <nRight> ] -> nRecno
  186.  *  $ARGUMENTS$
  187.  *     <aFields> is array of field blocks of fields you want to display.
  188.  *        Example to set up last name and first name in array:
  189.  *        aFields := {}
  190.  *        AADD(aFields, {"Last Name" , {||Names->Last}  } )
  191.  *        AADD(aFields, {"First Name", {||Names->First} } )
  192.  *
  193.  *     <bWhileCond> is the limiting WHILE condition as a block.
  194.  *        Example 1: { ||Names->Last == "JONES" }
  195.  *        Example 2: { ||Names->Last == "JONES" .AND. Names->First == "A"  }
  196.  *
  197.  *     <cKey> is the key to find top condition of WHILE.  
  198.  *        cLast  := "JONES     "
  199.  *        cFirst := "A"
  200.  *        Example 1: cKey := cLast
  201.  *        Example 2: cKey := cLast + cFirst
  202.  *
  203.  *     <nFreeze> is number of fields to freeze in TBrowse.  Defaults
  204.  *     to 0 if not passed.
  205.  *
  206.  *     <lSaveScrn> is a logical indicating whether or not you want to
  207.  *     save the screen from the calling program.  Defaults to .T. if
  208.  *     not passed.
  209.  *
  210.  *     <cColorList> is a list of colors for the TBrowse columns.
  211.  *     The 1st color is used as SAY/TBrowse Background and the
  212.  *     3rd and 4th colors are used as part of column:defColor := {3, 4}
  213.  
  214.  *     Thus if you pass a cColorList, you MUST pass at least 4 colors.
  215.  *     Defaults to "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R" if not passed.
  216.  *
  217.  *     <cColorShad> is the color of the TBrowse box shadow.  Defaults
  218.  *     to "N/N" if not passed.
  219.  *
  220.  *     <nTop>, <nLeft>, <nBottom>, <nRight> are the coordinates of
  221.  *     the area to display the TBrowse in.  Defaults to 2, 2,
  222.  *     MAXROW() - 2, MAXCOL() - 2 with shadowed box, i.e. full screen.
  223.  *  $RETURNS$
  224.  *     nRecno is the number of the record selected by the <Enter> key.
  225.  *     0 is returned if there are either no records matching the WHILE
  226.  *     condition or an <Esc> is pressed instead of an <Enter>
  227.  *  $DESCRIPTION$
  228.  *     This is a demonstration of TBrowse with a WHILE condition for an
  229.  *     indexed database.
  230.  *  $EXAMPLES$
  231.  *     * This example will only show those people with last name of "JONES"
  232.  *     * in the TBNames.dbf which contains at least the fields:
  233.  *     * Last, First, City AND is indexed on Last + First.
  234.  *     LOCAL nRecSel    := 0
  235.  *     LOCAL aFields    := {}
  236.  *     LOCAL bWhile     := {||TBNames->Last = "JONES"}
  237.  *     LOCAL cKey       := "JONES"
  238.  *     LOCAL nFreeze    := 1
  239.  *     LOCAL lSaveScrn  := .t.
  240.  *     LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
  241.  *     LOCAL cColorShad := "N/N"
  242.  *
  243.  *     USE TBNames INDEX TBNames NEW // indexed on Last + First
  244.  *
  245.  *     * Pass Heading as character and Field as Block including Alias
  246.  *     * To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
  247.  *     AADD(aFields, {"Last Name" , {||TBNames->Last}  } )
  248.  *     AADD(aFields, {"First Name", {||TBNames->First} } )
  249.  *     AADD(aFields, {"City"      , {||TBNames->City}  } )
  250.  *
  251.  *     IF FT_BRWSWHL( aFields, bWhile, cKey, nFreeze, lSaveScrn, ;
  252.  *        cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6) == 0
  253.  *        ? "Sorry, NO Records Were Selected"
  254.  *     ELSE
  255.  *        ? "You Selected: " + TBNames->Last +" "+ ;
  256.  *           TBNames->First +" "+ TBNames->City
  257.  *     ENDIF
  258.  *  $END$
  259.  */
  260.  
  261.  
  262. FUNCTION FT_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
  263.                     cColorList, cColorShad, nTop, nLeft, nBottom, nRight )
  264.  
  265.    LOCAL b, column, cType, i
  266.    LOCAL cHead, bField, lKeepScrn, cScrnSave
  267.    LOCAL cColorSave, cColorBack, nCursSave
  268.    LOCAL lMore, nKey, nPassRec
  269.    DEFAULT nFreeze TO 0, ;
  270.            lSaveScrn  TO .t., ;
  271.            cColorList TO "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R", ;
  272.            cColorShad TO "N/N", ;
  273.            nTop       TO 2, ;
  274.            nLeft      TO 2, ;
  275.            nBottom    TO MaxRow() - 2, ;
  276.            nRight     TO MaxCol() - 2
  277.    lKeepScrn := (PCOUNT() > 6)
  278.  
  279.    SEEK cKey
  280.    IF .NOT. FOUND() .OR. LASTREC() == 0
  281.       RETURN(0)
  282.    ENDIF
  283.  
  284.    /* make new browse object */
  285.    b := TBrowseDB(nTop, nLeft, nBottom, nRight)
  286.  
  287.    /* default heading and column separators */
  288.    b:headSep := "═╤═"
  289.    b:colSep  := " │ "
  290.    b:footSep := "═╧═"
  291.  
  292.    /* add custom 'TbSkipWhil' (to handle passed condition) */
  293.    b:skipBlock := {|x| TbSkipWhil(x, bWhileCond)}
  294.  
  295.    /* Set up substitute goto top and goto bottom */
  296.    /* with While's top and bottom records        */
  297.    b:goTopBlock    := {|| TbWhileTop(cKey)}
  298.    b:goBottomBlock := {|| TbWhileBot(cKey)}
  299.  
  300.    /* colors */
  301.    b:colorSpec := cColorList
  302.  
  303.    /* add a column for each field in the current workarea */
  304.    FOR i = 1 TO LEN(aFields)
  305.       cHead  := aFields[i, 1]
  306.       bField := aFields[i, 2]
  307.  
  308.       /* make the new column */
  309.       column := TBColumnNew( cHead, bField )
  310.  
  311.       /* these are color setups from tbdemo.prg from Nantucket */
  312.       * IF ( cType == "N" )
  313.       *   column:defColor := {5, 6}
  314.       *   column:colorBlock := {|x| if( x < 0, {7, 8}, {5, 6} )}
  315.       *ELSE
  316.       *   column:defColor := {3, 4}
  317.       *ENDIF
  318.  
  319.       /* To simplify I just used 3rd and 4th colors from passed cColorList */
  320.       /* This way 1st is SAY, 2nd is GET, 3rd and 4th are used here, 
  321.       /* 5th is Unselected Get, extras can be used as in tbdemo.prg */
  322.       column:defColor := {3, 4}
  323.  
  324.       b:addColumn(column)
  325.    NEXT
  326.  
  327.    /* freeze columns */
  328.    IF nFreeze <> 0
  329.       b:freeze := nFreeze
  330.    ENDIF
  331.  
  332.    /* save old screen and colors */
  333.    IF lSaveScrn
  334.       cScrnSave = SAVESCREEN(0, 0, MaxRow(), MaxCol())
  335.    ENDIF
  336.    cColorSave := SetColor()
  337.  
  338.    /* Background Color Is Based On First Color In Passed cColorList
  339.    cColorBack := IF(',' $ cColorList, ;
  340.       SUBSTR(cColorList, 1, AT(',', cColorList) - 1), cColorList )
  341.  
  342.    IF .NOT. lKeepScrn
  343.       SetColor(cColorBack)
  344.       CLEAR SCREEN
  345.    ENDIF
  346.  
  347.    /* make a window shadow */
  348.    SetColor(cColorShad)
  349.    @ nTop+1, nLeft+1 CLEAR TO nBottom+1, nRight+1
  350.    SetColor(cColorBack)
  351.    @ nTop, nLeft CLEAR TO nBottom, nRight
  352.    SetColor(cColorSave)
  353.  
  354.    nCursSave := SetCursor(0)
  355.  
  356.    lMore := .t.
  357.    WHILE (lMore)
  358.       /* stabilize the display */
  359.       nKey := 0
  360.       DISPBEGIN()
  361.       DO WHILE nKey == 0 .AND. .NOT. b:stable
  362.           b:stabilize()
  363.           nKey := InKey()
  364.       ENDDO
  365.       DISPEND()
  366.  
  367.       IF ( b:stable )
  368.          /* display is stable */
  369.          IF ( b:hitTop .OR. b:hitBottom )
  370.             Tone(125, 0)
  371.          ENDIF
  372.  
  373.          // Make sure that the current record is showing
  374.          // up-to-date data in case we are on a network.
  375.          DISPBEGIN()
  376.          b:refreshCurrent()
  377.          DO WHILE .NOT. b:stabilize()
  378.          ENDDO
  379.          DISPEND()
  380.  
  381.          /* everything's done; just wait for a key */
  382.          nKey := INKEY(0)
  383.       ENDIF
  384.  
  385.       /* process key */
  386.       DO CASE
  387.       CASE ( nKey == K_DOWN )
  388.          b:down()
  389.  
  390.       CASE ( nKey == K_UP )
  391.          b:up()
  392.  
  393.       CASE ( nKey == K_PGDN )
  394.          b:pageDown()
  395.  
  396.       CASE ( nKey == K_PGUP )
  397.          b:pageUp()
  398.  
  399.       CASE ( nKey == K_CTRL_PGUP )
  400.          b:goTop()
  401.  
  402.       CASE ( nKey == K_CTRL_PGDN )
  403.          b:goBottom()
  404.  
  405.       CASE ( nKey == K_RIGHT )
  406.          b:right()
  407.  
  408.       CASE ( nKey == K_LEFT )
  409.          b:left()
  410.  
  411.       CASE ( nKey == K_HOME )
  412.          b:home()
  413.  
  414.       CASE ( nKey == K_END )
  415.          b:end()
  416.  
  417.       CASE ( nKey == K_CTRL_LEFT )
  418.          b:panLeft()
  419.  
  420.       CASE ( nKey == K_CTRL_RIGHT )
  421.          b:panRight()
  422.  
  423.       CASE ( nKey == K_CTRL_HOME )
  424.          b:panHome()
  425.  
  426.       CASE ( nKey == K_CTRL_END )
  427.          b:panEnd()
  428.  
  429.       CASE ( nKey == K_ESC )
  430.          nPassRec := 0
  431.          lMore := .f.
  432.  
  433.       CASE ( nKey == K_RETURN )
  434.          nPassRec := RECNO()
  435.          lMore := .f.
  436.       ENDCASE
  437.    ENDDO  // for WHILE (lmore)
  438.  
  439.    /* restore old screen */
  440.    IF lSaveScrn
  441.       RESTSCREEN(0, 0, MaxRow(), MaxCol(), cScrnSave)
  442.    ENDIF
  443.    SetCursor(nCursSave)
  444.    SetColor(cColorSave)
  445.  
  446. RETURN (nPassRec)
  447.  
  448. /* -------------------------------------------------------------------- */
  449.  
  450. STATIC FUNCTION TbSkipWhil(n, bWhileCond)
  451.    LOCAL i := 0
  452.    IF n == 0 .OR. LASTREC() == 0
  453.       SKIP 0  // significant on a network
  454.  
  455.    ELSEIF ( n > 0 .AND. RECNO() <> LASTREC() + 1)
  456.       WHILE ( i < n )
  457.          SKIP 1
  458.          IF ( EOF() .OR. .NOT. Eval(bWhileCond) )
  459.             SKIP -1
  460.             EXIT
  461.          ENDIF
  462.          i++
  463.       ENDDO
  464.  
  465.    ELSEIF ( n < 0 )
  466.       WHILE ( i > n )
  467.          SKIP -1
  468.          IF ( BOF() )
  469.             EXIT
  470.          ELSEIF .NOT. Eval( (bWhileCond) )
  471.             SKIP
  472.             EXIT
  473.          ENDIF
  474.          i--
  475.       ENDDO
  476.    ENDIF
  477. RETURN (i)
  478. * EOFcn TbSkipWhil()
  479.  
  480. /* -------------------------------------------------------------------- */
  481.  
  482. STATIC FUNCTION TbWhileTop(cKey)
  483.    SEEK cKey
  484. RETURN NIL
  485.  
  486. /* -------------------------------------------------------------------- */
  487.  
  488. STATIC FUNCTION TbWhileBot(cKey)
  489.    * SeekLast: Finds Last Record For Matching Key
  490.    * Developed By Jon Cole
  491.    * With softseek set on, seek the first record after condition.
  492.    * This is accomplished by incrementing the right most character of the
  493.    * string cKey by one ascii character.  After SEEKing the new string,
  494.    * back up one record to get to the last record which matches cKey.
  495.    #include "set.ch"
  496.    LOCAL cSoftSave := SET(_SET_SOFTSEEK, .t.)
  497.    SEEK LEFT(cKey, LEN(cKey) -1) + CHR( ASC( RIGHT(cKey,1) ) +1)
  498.    SET(_SET_SOFTSEEK, cSoftSave)
  499.    SKIP -1
  500. RETURN NIL
  501.